home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
openpic.frm
< prev
next >
Wrap
Text File
|
1997-06-14
|
10KB
|
369 lines
VERSION 5.00
Begin VB.Form FOpenPictureFile
BorderStyle = 3 'Fixed Dialog
Caption = "Open Picture File"
ClientHeight = 3276
ClientLeft = 1392
ClientTop = 2196
ClientWidth = 7140
LinkTopic = "Form1"
ScaleHeight = 3276
ScaleWidth = 7140
Begin VB.CommandButton cmdNetwork
Caption = "Network..."
Height = 330
Left = 5565
TabIndex = 11
Top = 945
Width = 1380
End
Begin VB.ComboBox cboPicType
Height = 288
Left = 240
Style = 2 'Dropdown List
TabIndex = 6
Top = 2772
Width = 2484
End
Begin VB.TextBox txtPicType
BorderStyle = 0 'None
Height = 228
Left = 204
TabIndex = 5
Text = "*.bmp;*.wmf;*.ico;*.dib "
Top = 384
Width = 2448
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Cancel"
Height = 330
Left = 5565
TabIndex = 4
Top = 525
Width = 1380
End
Begin VB.CommandButton cmdOK
Caption = "OK"
Default = -1 'True
Height = 330
Left = 5565
TabIndex = 3
Top = 105
Width = 1380
End
Begin VB.FileListBox filPic
Height = 1032
Left = 180
TabIndex = 2
Top = 765
Width = 2505
End
Begin VB.DirListBox dirPic
Height = 1536
Left = 2940
TabIndex = 1
Top = 720
Width = 2412
End
Begin VB.DriveListBox drvPic
Height = 288
Left = 2928
TabIndex = 0
Top = 2760
Width = 2496
End
Begin VB.Image imgSound
Height = 264
Left = 6840
Top = 3000
Visible = 0 'False
Width = 288
End
Begin VB.Image imgPic
Height = 1425
Left = 5550
Top = 1560
Width = 1380
End
Begin VB.Label lbl
Caption = "File Name:"
Height = 228
Index = 1
Left = 192
TabIndex = 12
Top = 108
Width = 2436
End
Begin VB.Label lbl
Caption = "Directories:"
Height = 216
Index = 5
Left = 2916
TabIndex = 10
Top = 108
Width = 2436
End
Begin VB.Label lbl
Caption = "List Files of Type:"
Height = 312
Index = 4
Left = 204
TabIndex = 9
Top = 2436
Width = 2508
End
Begin VB.Label lbl
Caption = "Drives:"
Height = 315
Index = 3
Left = 2925
TabIndex = 8
Top = 2415
Width = 2430
End
Begin VB.Label lblPic
Height = 264
Left = 2928
TabIndex = 7
Top = 384
Width = 2436
End
End
Attribute VB_Name = "FOpenPictureFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Basic provides five constants, but we need six
Private Enum EPictureType
' vbPicTypeNone = 0
' vbPicTypeBitmap = 1
' vbPicTypeMetafile = 2
' vbPicTypeIcon = 3
' vbPicTypeEMetafile = 4
vbPicTypeCursor = 5
vbPicTypeWave = 6
End Enum
Private sInitDir As String
Private sFilePath As String ' d:\path\
Private sFileName As String ' base.ext
' Full file spec is sFilePath & sFileName
Private nsPicType As New Collection
Private dxPic As Integer, dyPic As Integer
Private ordMouse As Integer
Private ordPicType As Integer
Private afFilter As Long
' FileTitle is read-only
Friend Property Get FileTitle() As String
FileTitle = sFileName ' FileTitle is actually filename
End Property
Friend Property Get FileName() As String
If sFileName <> sEmpty Then
FileName = sFilePath & sFileName
' Else (commented out because strings are empty by default)
' FileName = sEmpty
End If
End Property
Friend Property Let FileName(sFilePathA As String)
sFilePath = sFilePathA
End Property
Friend Property Get InitDir() As String
InitDir = sInitDir
End Property
Friend Property Let InitDir(sInitDirA As String)
sInitDir = sInitDirA
End Property
Friend Property Get PicType() As Integer
PicType = ordPicType
End Property
Friend Property Get FilterType() As EFilterPicture
FilterType = afFilter
End Property
Friend Property Let FilterType(afFilterA As EFilterPicture)
afFilter = afFilterA
End Property
Private Sub cboPicType_Change()
txtPicType.Text = nsPicType(cboPicType.ListIndex + 1)
End Sub
Private Sub cboPicType_Click()
txtPicType.Text = nsPicType(cboPicType.ListIndex + 1)
filPic.Pattern = txtPicType.Text
End Sub
Private Sub cmdCancel_Click()
sFileName = sEmpty
Unload Me
End Sub
Private Sub cmdNetwork_Click()
Dim errOK As Long
errOK = WNetConnectionDialog(Me.hWnd, 1) ' WNTYPE_DRIVE
End Sub
Private Sub cmdOK_Click()
Unload Me
End Sub
Private Sub dirPic_Change()
filPic.Path = dirPic.Path
If filPic.ListCount > 0 Then
filPic.ListIndex = 0
End If
End Sub
Private Sub drvPic_Change()
dirPic.Path = drvPic.Drive
End Sub
Private Sub filPic_DblClick()
Unload Me
End Sub
Private Sub filPic_PathChange()
sFilePath = NormalizePath(filPic.Path)
If filPic.ListCount > 0 Then filPic.ListIndex = 0
End Sub
Private Sub filPic_Click()
sFileName = filPic.FileName
UpdateFile sFilePath & sFileName
End Sub
Private Sub filPic_PatternChange()
If filPic.ListCount > 0 Then
filPic.ListIndex = 0
End If
End Sub
Private Sub Form_Initialize()
BugMessage "Initialize"
End Sub
Private Sub Form_Load()
BugMessage "Load"
If sInitDir <> sEmpty Then
dirPic.Path = NormalizePath(sInitDir)
Else
sInitDir = NormalizePath(dirPic.Path)
End If
dxPic = imgPic.Width
dyPic = imgPic.Height
With cboPicType
If afFilter = 0 Then afFilter = efpEverything
If afFilter And efpAllPicture Then
.AddItem "All Picture Files"
nsPicType.Add "*.bmp;*.dib;*.ico;*.wmf;*.cur"
End If
If afFilter And efpBitmap Then
.AddItem "Bitmaps (*.BMP;*.DIB)"
nsPicType.Add "*.bmp;*.dib"
End If
If afFilter And efpMetafile Then
.AddItem "Metafiles (*.WMF)"
nsPicType.Add "*.wmf"
End If
If afFilter And efpIcon Then
.AddItem "Icons (*.ICO)"
nsPicType.Add "*.ico"
End If
If afFilter And efpCursor Then
.AddItem "Cursors (*.CUR;*.ICO)"
nsPicType.Add "*.cur;*.ico"
End If
If afFilter And efpWave Then
.AddItem "Waves (*.WAV)"
nsPicType.Add "*.wav"
End If
If afFilter And efpAllFile Then
.AddItem "All Files (*.*)"
nsPicType.Add "*.*"
End If
If .ListCount Then .ListIndex = 0
End With
' Save mouse pointer so we can restore
ordMouse = MousePointer
dirPic_Change
filPic_PathChange
filPic_Click
End Sub
Private Sub UpdateFile(sFile As String)
MousePointer = ordMouse
With imgPic
.Visible = False
lblPic.Caption = sFile
.Stretch = False
If UCase$(Right$(sFile, 4)) = ".WAV" Then
sndPlaySound sFile, 0
.Picture = imgSound.Picture
.Visible = True
ordPicType = vbPicTypeWave
Exit Sub
End If
On Error Resume Next
.Picture = LoadPicture(sFile)
If Err Then Exit Sub
On Error GoTo 0
ordPicType = .Picture.Type
Select Case .Picture.Type
Case vbPicTypeIcon
If UCase$(Right$(sFile, 4)) = ".CUR" Then
ordPicType = vbPicTypeCursor
On Error Resume Next
MousePointer = vbCustom
MouseIcon = .Picture
If Err = 0 Then Exit Sub
On Error GoTo 0
End If
Case vbPicTypeBitmap
If ScaleX(.Picture.Width) > dxPic Then
imgPic.Height = (dxPic / ScaleX(.Picture.Width)) * _
ScaleY(.Picture.Height)
imgPic.Width = dxPic
.Stretch = True
End If
If ScaleY(.Picture.Height) > dyPic Then
imgPic.Width = (dyPic / ScaleY(.Picture.Height)) * _
ScaleX(.Picture.Width)
imgPic.Height = dyPic
.Stretch = True
End If
BugMessage "Palette: " & .Picture.hPal
Case vbPicTypeMetafile, vbPicTypeEMetafile
imgPic.Width = dxPic
imgPic.Height = dyPic
.Stretch = True
End Select
BugMessage "Type: " & .Picture.Type
BugMessage "Handle: " & .Picture.Handle
.Visible = True
End With
End Sub
Private Sub Form_Terminate()
BugMessage "Terminate"
End Sub
Private Sub Form_Unload(Cancel As Integer)
BugMessage "Unload"
End Sub
Property Let Dummy(f As Boolean)
Debug.Print f
End Property